{-# LANGUAGE TypeFamilies, QuasiQuotes #-}

module Polarity (qK, module Polarity) where

import Type.Spine (qK)


-- a complete 4-lattice of polarities
data PosNeg; data Pos; data Neg; data Neutral


-- the second argument is a ()-terminated, right-nested, (,)-list of remaining
-- actuals (including the argument whose polarity is being queried)
type family Polarity t args

type instance Polarity ([qK|*->*|] Maybe) ([qK|*|] a, ()) = Pos
type instance Polarity ([qK|*->*|] []) ([qK|*|] a, ()) = Pos

type instance Polarity ([qK|*->*->*|] (,)) ([qK|*|] a, ([qK|*|] b, ())) = Pos
type instance Polarity ([qK|*->*|] ((,) a)) ([qK|*|] b, ()) = Pos
type instance Polarity ([qK|*->*->*|] Either) ([qK|*|] a, ([qK|*|] b, ())) = Pos
type instance Polarity ([qK|*->*|] (Either a)) ([qK|*|] b, ()) = Pos

type instance Polarity ([qK|*->*->*|] (->)) ([qK|*|] a, ([qK|*|] b, ())) = Neg
type instance Polarity ([qK|*->*|] ((->) a)) ([qK|*|] b, ()) = Pos

type family Invert p
type instance Invert PosNeg  = PosNeg
type instance Invert Pos     = Neg
type instance Invert Neg     = Pos
type instance Invert Neutral = Neutral

type family LUB p1 p2
type instance LUB PosNeg p2        = PosNeg
type instance LUB Pos      PosNeg  = PosNeg
type instance LUB Pos      Pos     = Pos
type instance LUB Pos      Neg     = PosNeg
type instance LUB Pos      Neutral = Pos
type instance LUB Neg      PosNeg  = PosNeg
type instance LUB Neg      Pos     = PosNeg
type instance LUB Neg      Neg     = Neg
type instance LUB Neg      Neutral = Neg
type instance LUB Neutral  p2      = p2

type family Compose p1 p2
type instance Compose PosNeg  PosNeg  = PosNeg
type instance Compose PosNeg  Pos     = PosNeg
type instance Compose PosNeg  Neg     = PosNeg
type instance Compose PosNeg  Neutral = Neutral
type instance Compose Pos     p2      = p2
type instance Compose Neg     p2      = Invert p2
type instance Compose Neutral p2      = Neutral

type family PolarityCase p top pos neg bot
type instance PolarityCase PosNeg  top pos neg bot = top
type instance PolarityCase Pos     top pos neg bot = pos
type instance PolarityCase Neg     top pos neg bot = neg
type instance PolarityCase Neutral top pos neg bot = bot
